home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / pcscheme / geneva / sources.exe / SOURCES / ASM / VARS.ASM < prev    next >
Encoding:
Assembly Source File  |  1993-01-22  |  25.1 KB  |  895 lines
  1. ;* VARS.ASM
  2. ;************************************************************************
  3. ;*                                    *
  4. ;*        PC Scheme/Geneva 4.00 Borland TASM code            *
  5. ;*                                    *
  6. ;* (c) 1985-1988 by Texas Instruments, Inc. See COPYRIGHT.TXT        *
  7. ;* (c) 1992 by L. Bartholdi & M. Vuilleumier, University of Geneva    *
  8. ;*                                    *
  9. ;*----------------------------------------------------------------------*
  10. ;*                                    *
  11. ;*        Vector & Variable support (interpreter support)        *
  12. ;*                                    *
  13. ;*----------------------------------------------------------------------*
  14. ;*                                    *
  15. ;* Created by: John Jensen        Date: 1985            *
  16. ;* Revision history:                            *
  17. ;* - 5 Feb 88:    MEMV, ASSV use EQV's definition of number equality    *
  18. ;*    (which is "=", *not* "equal"). (rb)                *
  19. ;* - 18 Jun 92:    Renaissance (Borland Compilers, ...)            *
  20. ;*                                    *
  21. ;*                    ``In nomine omnipotentii dei''    *
  22. ;************************************************************************
  23. IDEAL
  24. %PAGESIZE    60, 132
  25. MODEL    small
  26. LOCALS    @@
  27.  
  28.     INCLUDE    "scheme.ash"
  29.     INCLUDE "interprt.ash"
  30.  
  31. CODESEG
  32. ;************************************************************************
  33. ;*            Lookup Symbol is Assoc List            *
  34. ;*                                    *
  35. ;* Purpose:    To search a linked list for a given pointer        *
  36. ;*                                    *
  37. ;* Description:    The list to be searched has the following format:    *
  38. ;*                                    *
  39. ;*        +--------+--------+        +--------+-------+    *
  40. ;*        +-->|symbol->|value ->|        +-->|symbol->|value->|    *
  41. ;*        |    +--------+--------+        |    +--------+-------+    *
  42. ;*        |                    |                *
  43. ;*    +---+----+--------+        +---+----+--------+        *
  44. ;*    |   o     |   o----+----...----->|   o     | (nil)  |        *
  45. ;*    +--------+--------+        +--------+--------+        *
  46. ;*                                    *
  47. ;*    The symbol portion of the list entries are compared against the    *
  48. ;*    search symbol for an identical match. When found, a pointer to    *
  49. ;*    the matched symbol's symbol-value entry is returned. If the    *
  50. ;*    symbol is not found, a value of nil is returned.        *
  51. ;*                                    *
  52. ;* Registers upon entry:    ax - search symbol's displacement    *
  53. ;*                bx - page number of list to search    *
  54. ;*                dl - search symbol's page number    *
  55. ;*                si - displacement within page number    *
  56. ;*                    of list to search        *
  57. ;*                                    *
  58. ;* Registers on exit:    bl - page number of cell whose car is the    *
  59. ;*                search symbol, or zero if not found    *
  60. ;*            di - displacement of list cell found, or nil    *
  61. ;*            es:[di] - points to cell found            *
  62. ;************************************************************************
  63. PROC    lookup    FAR
  64. @@loop:
  65.     mov    cx, bx            ; Save Page number
  66.     ldpage    es, bx
  67.     mov    bl, [(LISTDEF es:si).car.page]
  68.     mov    di, [(LISTDEF es:si).car.disp]
  69.     cmp    [ptype+bx], LISTTYPE
  70.     jne    @@error
  71.     ldpage    es, bx
  72.     cmp    ax, [(LISTDEF es:di).car.disp]
  73.     jne    @@notfound
  74.     cmp    dl, [(LISTDEF es:di).car.page]
  75.     je    @@found
  76. @@notfound:
  77.     mov    bx, cx            ; restore page number
  78.     ldpage    es, bx
  79.     mov    bl, [(LISTDEF es:si).cdr.page]
  80.     cmp    [ptype+bx], LISTTYPE
  81.     jne    @@error
  82.     mov    si, [(LISTDEF es:si).cdr.disp]
  83.     or    bx, bx
  84.     jnz    @@loop
  85.     xor    di, di            ; make bx:di nil
  86. @@found:
  87.     ret
  88. @@error:
  89.     xor    bx, bx            ; create a nil pointer to return
  90.     xor    si, si
  91.     ret
  92. ENDP    lookup
  93.  
  94. ;************************************************************************
  95. ;* Macro support for global/fluid variable lookup            *
  96. ;************************************************************************
  97. MACRO    load    reg_p
  98.     get2op
  99.     save    <si>
  100.     mov    bl, al            ; copy destination register number to di
  101.     mov    di, bx
  102.     mov    bl, ah            ; isolate constant number
  103. IFIDN    <reg_p>, <REG>
  104.     mov    si, [regs+bx.page]
  105.     mov    ax, [regs+bx.disp]
  106. ELSE
  107.     mov    ax, bx            ; bx <- constant number * 3
  108.     shl    ax, 1
  109.     add    bx, ax
  110.     add    bx, [cb_reg.disp]    ; make displacement relative
  111.     xor    ax, ax
  112.     mov    al, [(CODEDEF es:bx).consts.page]
  113.     mov    si, ax
  114.     mov    ax, [(CODEDEF es:bx).consts.disp]
  115. ENDIF
  116.     cmp    [ptype+si], SYMBTYPE
  117.     jne    @@error
  118.     push    di
  119.     mov    dx, si            ; copy symbol's page number into dx
  120.     mov    di, [fnv_reg.page]
  121.     mov    si, [fnv_reg.disp]
  122.     mov    bx, di            ; bx <= page number
  123.     call    lookup            ; search the environment for symbol
  124.     or    bx, bx            ; symbol found ?
  125.     pop    bx            ; restore register number
  126.     je    @@notfound
  127.     mov    ax, [(LISTDEF es:di).cdr.disp]    ; load value
  128.     mov    dl, [(LISTDEF es:di).cdr.page]
  129.     mov    [regs+bx.disp], ax
  130.     mov    [regs+bx.bpage], dl
  131.     jmp    next_pc
  132. ENDM
  133.  
  134. ;************************************************************************
  135. ;*                            al    ah    *
  136. ;* Fluid lookup                    FLUID    dest,    const    *
  137. ;*                                    *
  138. ;* Purpose:    Interpreter support for fluid variable lookup        *
  139. ;************************************************************************
  140. PROC    ld_fluid
  141.     load    CONST
  142. @@error:
  143.     lea    bx, [fluidmsg]
  144. DATASEG
  145. fluidmsg DB    "LD-FLUID", 0
  146. CODESEG
  147.     jmp    src_err
  148. @@notfound:
  149. in_ld_fluid:
  150.     lea    cx, [fnv_reg]
  151.     corpage dx            ; adjust page number for call to C routine
  152.     add    bx, OFFSET regs        ; compute address of destination register
  153.     call    sym_undefined C, dx, ax, cx, bx
  154.     restore <si>
  155.     sub    si, 3            ; back up PC to retry fluid load
  156.     jmp    sch_err
  157. ENDP
  158.  
  159. ;************************************************************************
  160. ;*                            al    ah    *
  161. ;* Fluid lookup-register operand        FLUID-R    dest,    sym    *
  162. ;*                                    *
  163. ;* Purpose:    Interpreter support for fluid variable lookup        *
  164. ;************************************************************************
  165. PROC    ld_fl_r
  166.     load    REG
  167. @@error:
  168.     lea    bx, [fluidmsg]
  169.     jmp    src_err
  170. @@notfound:
  171.     jmp    in_ld_fluid
  172. ENDP
  173.  
  174. ;************************************************************************
  175. ;*                            al    ah    *
  176. ;* set-fluid!                ST-FLUID    src,    const    *
  177. ;*                                    *
  178. ;* Purpose:    Interpreter support for fluid assignment.        *
  179. ;************************************************************************
  180. PROC    st_fluid
  181.     get2op
  182.     save    <si>
  183.     push    ax            ; save symbol/value register numbers
  184.     mov    bl, ah
  185.     mov    ax, bx            ; bx <- constant number * 3
  186.     shl    ax, 1
  187.     add    bx, ax
  188.     add    bx, [cb_reg.disp]    ; make disp relative
  189.     xor    ax, ax
  190.     mov    al, [(CODEDEF es:bx).consts.page]
  191.     mov    di, ax
  192.     mov    ax, [(CODEDEF es:bx).consts.disp]
  193.     cmp    [ptype+di], SYMBTYPE
  194.     jne    @@error
  195.     mov    dx, di
  196.     mov    di, [fnv_reg.page]
  197.     mov    si, [fnv_reg.disp]
  198.     mov    bx, di            ; Page number
  199.     call    lookup            ; search fluid environment for symbol
  200.     or    bx, bx            ; symbol found in fluid environment?
  201.     je    @@notfound
  202.     pop    ax            ; restore operands
  203.     mov    bl, al
  204.     mov    dl, [regs+bx.bpage]    ; set cdr of fluid var entry to reg
  205.     mov    ax, [regs+bx.disp]
  206.     mov    [(LISTDEF es:di).cdr.page], dl
  207.     mov    [(LISTDEF es:di).cdr.disp], ax
  208.     jmp    next_pc
  209.  
  210. @@error:
  211.     lea    bx, [@@msg]
  212. DATASEG
  213. @@msg    DB    "SET-FLUID!", 0
  214. CODESEG
  215.     jmp    src_err
  216.  
  217. @@notfound:
  218.     pop    cx            ; restore instruction's operands
  219.     xor    ch, ch
  220.     add    cx, OFFSET regs        ; compute address of source register
  221.     corpage dx            ; convert page number to C's notation
  222.     call    not_fluidly_bound C, dx, ax, cx
  223.     restore <si>
  224.     sub    si, 3            ; retry the set-fluid! operation
  225.     jmp    sch_err
  226. ENDP    st_fluid
  227.  
  228. ;************************************************************************
  229. ;*    fluid-bound?                    FLUID?    reg    *
  230. ;************************************************************************
  231. PROC    fluid_p
  232.     get1op
  233.     save    <si>
  234.     mov    bx, ax
  235.     add    bx, OFFSET regs
  236.     mov    ax, [(REG bx).disp]
  237.     mov    dx, [(REG bx).page]
  238.     mov    di, dx
  239.     cmp    [ptype+di], SYMBTYPE
  240.     jne    @@error
  241.     mov    di, [fnv_reg.page]
  242.     mov    si, [fnv_reg.disp]
  243.     push    bx
  244.     mov    bx, di            ; Page number
  245.     call    lookup
  246.     or    bx, bx
  247.     pop    bx
  248.     jz    @@notfound
  249.     mov    [(REG bx).bpage], T_PAGE*2 ; symbol is fluidly bound
  250.     mov    [(REG bx).disp], T_DISP
  251.     jmp    next_pc
  252. @@notfound:
  253.     xor    ax, ax
  254.     mov    [(REG bx).bpage], al
  255.     mov    [(REG bx).disp], ax
  256.     jmp    next_pc
  257. @@error:
  258.     lea    bx, [@@msg]
  259. DATASEG
  260. @@msg    DB    "FLUID-BOUND?", 0
  261. CODESEG
  262.     jmp    src_err
  263. ENDP    fluid_p
  264.  
  265. ;************************************************************************
  266. ;*                            al    ah    *
  267. ;* Bind fluid variable                BIND-FL    const,    src    *
  268. ;*                                    *
  269. ;* Purpose: Interpreter support for binding (creating and defining)    *
  270. ;*        fluid variables                        *
  271. ;*                                    *
  272. ;* Note: At entry to this routine, es is set to point to the beginning    *
  273. ;*        of the page containing the current code block.        *
  274. ;************************************************************************
  275. PROC    bind_fl
  276.     get2op
  277.     save    <si>
  278.     mov    bl, ah            ; copy the source register number
  279.     lea    di, [regs+bx]
  280.     mov    bl, al            ; bx <- constant number * 3
  281.     mov    ax, bx
  282.     shl    ax, 1
  283.     add    bx, ax
  284.     add    bx, [cb_reg.disp]    ; make disp relative
  285.     xor    dx, dx
  286.     mov    dl, [(CODEDEF es:bx).consts.page]
  287.     mov    ax, [(CODEDEF es:bx).consts.disp]
  288.     mov    [tmp_reg.page], dx
  289.     mov    [tmp_reg.disp], ax
  290.     lea    ax, [tmp_reg]
  291.     call    cons C, ax, ax, di    ; tmp_reg := (symbol . value)
  292.     lea    ax, [tmp_reg]
  293.     lea    bx, [fnv_reg]
  294.     call    cons C, bx, ax, bx    ; FNV := ((symbol . value) FNV)
  295.     jmp    next_pc
  296. ENDP    bind_fl
  297.  
  298. ;************************************************************************
  299. ;* Unbind fluid variable            UNBIND-FL    const    *
  300. ;*                                    *
  301. ;* Purpose: Interpreter support for unbinding (deleting) fluid        *
  302. ;*        variables                        *
  303. ;*                                    *
  304. ;* Description:    The fluid environment is maintained as an a-list, so    *
  305. ;*        dropping fluids consists of cdr-ing down the list for    *
  306. ;*        the required number of elements.            *
  307. ;************************************************************************
  308. PROC    unbind_f
  309.     get1op
  310.     save    <si>
  311.     mov    cx, ax
  312.     mov    bl, [fnv_reg.bpage]    ; load the fluid environment pointer
  313.     mov    di, [fnv_reg.disp]
  314. @@loop:
  315.     ldpage    es, bx
  316.     mov    bl, [(LISTDEF es:di).cdr.page]
  317.     mov    di, [(LISTDEF es:di).cdr.disp]
  318.     loop    @@loop
  319.     mov    [fnv_reg.bpage], bl
  320.     mov    [fnv_reg.disp], di
  321.     jmp    next_pc
  322. ENDP    unbind_f
  323.  
  324. ;************************************************************************
  325. ;* Allocate vector                VEC-ALLOCATE    dest    *
  326. ;*                                    *
  327. ;* Purpose: Interpreter support for the allocation of vector data    *
  328. ;*        objects.                        *
  329. ;*                                    *
  330. ;* Note: Vectors are set to zero after they are allocated to insure    *
  331. ;*        that all entries are valid Scheme pointers. Zeroing a    *
  332. ;*        vector effectively sets all the entries to nil.        *
  333. ;*        If an array were not initialized, the garbage collector    *
  334. ;*        would interpret any leftover data as pointers, and    *
  335. ;*        might cause the Scheme Virtual Machine to go off the    *
  336. ;*        deep end.                        *
  337. ;************************************************************************
  338. PROC    vec_allo
  339.     get1op
  340.     save    <si>
  341.     mov    bx, ax
  342.     add    bx, OFFSET regs
  343.     cmp    [(REG bx).bpage], SPECFIX*2
  344.     jne    @@error
  345.     mov    ax, [(REG bx).disp]
  346.     or    ax, ax
  347.     jl    @@error
  348.     cmp    ax, 7fffh / (SIZE POINTER)
  349.     jae    @@toobig
  350.     mov    cx, ax            ; ax <- ax * 3 (multiply number of
  351.     shl    ax, 1            ; elements by size of pointer)
  352.     add    ax, cx
  353.     mov    cx, VECTTYPE
  354.     push    bx
  355.     call    alloc_block C, bx, cx, ax
  356.     pop    bx            ; recover address of reg holding vector ptr
  357.     mov    ax, [(REG bx).page]
  358.     corpage ax
  359.     call    zero_blk C, ax, [(REG bx).disp]
  360.     jmp    next_pc
  361. @@error:
  362.     mov    si, [(REG bx).page]
  363.     cmp    [ptype+si], BIGTYPE
  364.     je    @@toobig
  365.     lea    bx, [@@msg]
  366. DATASEG
  367. @@msg    DB    "MAKE-VECTOR", 0
  368. CODESEG
  369.     jmp    src_err
  370. @@toobig:
  371.     restore <si>
  372.     sub    si, 2
  373.     lea    ax, [@@msg]
  374.     call    disassemble C, ax, si
  375.     mov    ax, 1
  376.     mov    bx, VECTOR_SIZE_LIMIT_ERROR
  377.     call    set_numeric_error C, ax, bx, [tmp_adr]
  378.     jmp    sch_err
  379. ENDP    vec_allo
  380.  
  381. ;************************************************************************
  382. ;* Vector size                    VECTOR-SIZE    dest    *
  383. ;*                                    *
  384. ;* Purpose: Interpreter support for the vector-size function to return    *
  385. ;*        the number of elements in a vector data object.        *
  386. ;*                                    *
  387. ;* Description: The number of elements in a vector data object is    *
  388. ;*        determined by dividing the number of bytes (obtained    *
  389. ;*        from the block header of the vector data object) by the *
  390. ;*        number of bytes in a pointer (3), and subtracting the    *
  391. ;*        overhead of the block header (3 bytes).            *
  392. ;************************************************************************
  393. PROC    vec_size
  394.     get1op
  395.     mov    bx, ax
  396.     add    bx, OFFSET regs
  397.     save    <si>
  398.     mov    si, [(REG bx).page]
  399.     mov    di, [(REG bx).disp]
  400.     cmp    [ptype+si], VECTTYPE
  401.     jne    @@error
  402.     ldpage    es, si
  403.     mov    ax, [(VECDEF es:di).len]
  404.     xor    dx, dx        ; extend to double word
  405.     mov    cx, SIZE POINTER
  406.     div    cx
  407.     dec    ax        ; subtract off block overhead
  408.     mov    [(REG bx).disp], ax
  409.     mov    [(REG bx).bpage], SPECFIX*2
  410.     jmp    next_pc
  411.  
  412. @@error:
  413.     lea    bx, [@@msg]
  414. DATASEG
  415. @@msg    DB    "VECTOR-SIZE", 0
  416. CODESEG
  417.     jmp    src_err
  418. ENDP    vec_size
  419.  
  420. ;************************************************************************
  421. ;*                            al    ah    *
  422. ;* vector fill                vec-fill    vect,    val    *
  423. ;*                                    *
  424. ;* Purpose: Scheme intepreter support for the vector-fill operation    *
  425. ;************************************************************************
  426. PROC    vec_fill
  427.     get2op
  428.     save    <si>
  429.     xor    bx, bx
  430.     mov    bl, al            ; copy number of register containing vector
  431.     mov    di, [regs+bx.disp]
  432.     mov    bl, [regs+bx.bpage]
  433.     cmp    [ptype+bx], VECTTYPE
  434.     jne    @@error
  435.     ldpage    es, bx
  436.     mov    bl, ah            ; copy pointer to fill value
  437.     mov    ax, [regs+bx.disp]    ; load value to fill array
  438.     mov    dl, [regs+bx.bpage]
  439.     mov    cx, [(VECDEF es:di).len]
  440.     sub    cx, OFFSET (TYPE VECDEF).data
  441.     jle    @@done
  442. @@loop:
  443.     mov    [(VECDEF es:di).data.page], dl
  444.     mov    [(VECDEF es:di).data.disp], ax
  445.     add    di, SIZE POINTER
  446.     sub    cx, SIZE POINTER
  447.     jg    @@loop
  448. @@done:
  449.     jmp    next_pc
  450.  
  451. @@error:
  452.     lea    bx, [@@msg]
  453. DATASEG
  454. @@msg    DB    "VECTOR-FILL!", 0
  455. CODESEG
  456.     jmp    src_err
  457. ENDP    vec_fill
  458.  
  459. ;************************************************************************
  460. ;*                            al    ah    *
  461. ;* (memq obj list)                MEMQ    dest,    src    *
  462. ;*                                    *
  463. ;* Purpose: Scheme interpreter support for the memq primitive        *
  464. ;************************************************************************
  465. PROC    memq
  466.     get2op
  467.     save    <si>
  468.     mov    bl, al
  469. in_memq:
  470.     lea    di, [regs+bx]        ; destination address in di
  471.     mov    al, [(REG di).bpage] ; object pointer in al:dx
  472.     mov    dx, [(REG di).disp]
  473.     mov    bl, ah
  474.     mov    si, [regs+bx.disp]    ; list register in bl:si
  475.     mov    bl, [regs+bx.bpage]
  476.     jmp    @@more
  477. @@next:
  478.     cmp    [s_break], 0
  479.     jne    @@break
  480.     mov    bl, [(LISTDEF es:si).cdr.page]
  481.     mov    si, [(LISTDEF es:si).cdr.disp]
  482. @@more:
  483.     or    bl, bl
  484.     jz    @@fail
  485.     cmp    [ptype+bx], LISTTYPE
  486.     jne    @@fail
  487.     ldpage    es, bx
  488.     cmp    dx, [(LISTDEF es:si).car.disp]
  489.     jne    @@next
  490.     cmp    al, [(LISTDEF es:si).car.page]
  491.     jne    @@next
  492.  
  493.     mov    [(REG di).bpage], bl ; set destination register
  494.     mov    [(REG di).disp], si
  495.     jmp    next_pc
  496. @@fail:
  497.     xor    ax, ax
  498.     mov    [(REG di).bpage], al
  499.     mov    [(REG di).disp], ax
  500.     jmp    next_pc
  501. @@break:
  502. in_shiftbreak:
  503.     mov    ax, 3
  504.     call    restart C, ax        ; link to Scheme debugger
  505. ENDP    memq
  506.  
  507. ;************************************************************************
  508. ;*                            al    ah    *
  509. ;* (memv key list)                MEMV    dest,    src    *
  510. ;*                            key,    list    *
  511. ;*                                    *
  512. ;* Purpose: Scheme interpreter support for the memv primitive        *
  513. ;************************************************************************
  514. PROC    memv
  515.     get2op
  516.     save    <si>
  517.     mov    bl, al
  518.     mov    di, [regs+bx.page]
  519.     test    [attrib+di], FIXNUMS or FLONUMS or BIGNUMS or STRINGS
  520.     jnz    @@notmemq
  521.     jmp    in_memq
  522. @@notmemq:
  523.     test    [attrib+di], FIXNUMS or FLONUMS or BIGNUMS
  524.     jnz    @@notmember
  525.     jmp    in_member
  526. @@notmember:                ; key is a number
  527.     lea    di, [regs+bx]        ; di=address of VM reg containing key
  528.     mov    bl, ah
  529.     lea    si, [regs+bx]        ; si=address of VM reg containing list
  530.     push    [(REG si).page]        ; tempsave "list" VM reg
  531.     push    [(REG si).disp]
  532.     jmp    @@next
  533.  
  534. @@break:
  535.     jmp    in_shiftbreak
  536. @@more:                    ; this list element didn't match, go to the next element
  537.     cmp    [s_break], 0        ; shift-break pressed?
  538.     jne    @@break
  539.     mov    bx, [(REG si).page]
  540.     ldpage    es, bx
  541.     mov    bx, [(REG si).disp]
  542.     mov    cl, [(LISTDEF es:bx).cdr.page]
  543.     mov    ch, 0
  544.     mov    ax, [(LISTDEF es:bx).cdr.disp]
  545.     mov    [(REG si).page], cx
  546.     mov    [(REG si).disp], ax
  547. @@next:                    ; loop over each element in the list
  548.     mov    bx, [(REG si).page]
  549.     cmp    bx, NIL_PAGE        ; at end of list?
  550.     je    @@finished
  551.     cmp    [ptype+bx], LISTTYPE    ; looking at a cons?
  552.     jne    @@finished
  553.     ldpage    es, bx            ; get cons into memory
  554.     mov    bx, [(REG si).disp]    ; es:bx=address of cons cell
  555.     mov    bl, [(LISTDEF es:bx).car.page]
  556.     mov    bh, 0
  557.     test    [attrib+bx], FIXNUMS or FLONUMS or BIGNUMS
  558.     jz    @@more            ; key and list element are both numeric
  559.     mov    [tmp_reg.page], bx
  560.     mov    bx, [(REG si).disp]
  561.     mov    bx, [(LISTDEF es:bx).car.disp]
  562.     mov    [tmp_reg.disp], bx
  563.     lea    bx, [tmp_reg]
  564.     cmp    [(REG di).bpage], SPECFIX*2
  565.     jne    @@float            ; begin comparison of key and list element
  566.     cmp    [(REG bx).bpage], SPECFIX*2
  567.     jne    @@float
  568.                     ; both key and list element are fixnums
  569.     mov    ax, [(REG bx).disp]    ; ax = list element,
  570.     cmp    ax, [(REG di).disp]    ; [di] = key
  571.     jne    @@more
  572. @@found:                ; we have a match, copy list object-pointer to VM register containing key
  573.     mov    ax, [(REG si).disp]
  574.     mov    dx, [(REG si).page]
  575.     mov    [(REG di).disp], ax
  576.     mov    [(REG di).page], dx
  577.     jmp    @@done
  578. @@finished:                ; we have no match, copy '() to VM register containing key
  579.     xor    ax, ax
  580.     mov    [(REG di).page], ax
  581.     mov    [(REG di).disp], ax
  582. @@done:
  583.     pop    [(REG si).disp]        ; restore original contents "list" VM reg
  584.     pop    [(REG si).page]
  585.     jmp    next_pc
  586. @@float:                ; key and list element are not both fixnums, do = operation
  587.     mov    ax, EQ_OP
  588.     call    arith2 C, ax, di, bx
  589.     or    ax, ax
  590.     jge    @@couldbe
  591.     pop    [(REG si).disp]        ; restore original contents "list" VM reg
  592.     pop    [(REG si).page]
  593.     jmp    sch_err
  594. @@couldbe:
  595.     jg    @@found            ; ax positive means "true"
  596.     jmp    @@more
  597. ENDP    memv
  598.  
  599. ;************************************************************************
  600. ;*                            al    ah    *
  601. ;* (member key list)                MEMBER    dest,    src    *
  602. ;*                            key,    list    *
  603. ;*                                    *
  604. ;* Purpose: Scheme interpreter support for the member primitive        *
  605. ;************************************************************************
  606. PROC    member
  607.     get2op
  608.     save    <si>
  609.     mov    bl, al
  610.     mov    di, [regs+bx.page]    ; load search object's page number
  611.     test    [attrib+di], FIXNUMS or SYMBOLS or CONTINU or CLOSURE or PORTS or CODE or CHARS
  612.     jz    @@notmemq
  613.     jmp    in_memq
  614. @@notmemq:
  615. in_member:
  616.     lea    di, [regs+bx]
  617.     mov    cl, [(REG di).bpage] ; load pointer to object in cl:dx
  618.     mov    dx, [(REG di).disp]
  619.     mov    bl, cl
  620.     mov    ch, [ptype+bx]        ; load type code of search object
  621.     mov    bl, ah            ; copy pointer to search list
  622.     mov    si, [regs+bx.disp]    ; load contents of "list" register
  623.     mov    bl, [regs+bx.bpage]
  624.     jmp    @@go
  625. @@more:
  626.     mov    ax, bx
  627.     mov    bl, [(LISTDEF es:si).car.page]
  628.     cmp    ch, [ptype+bx]
  629.     jne    @@nxt
  630.     push    ax cx dx si        ; save registers across call
  631.     xor    dx, dx
  632.     mov    dl, [(LISTDEF es:si).car.page]
  633.     mov    ax, [(LISTDEF es:si).car.disp]
  634.     mov    [tmp_reg.page], dx        ; tmp_reg := (car list)
  635.     mov    [tmp_reg.disp], ax
  636.     lea    bx, [tmp_reg]
  637.  
  638.     call    sequal_p C, di, bx
  639.     pop    si dx cx bx
  640.     ldpage    es, bx            ; restore page paragraph address
  641.     or    ax, ax
  642.     jne    @@found
  643. @@nxt:
  644.     cmp    [s_break], 0        ; has shift-break key been depressed?
  645.     jne    @@break
  646.     mov    bl, [(LISTDEF es:si).cdr.page]
  647.     mov    si, [(LISTDEF es:si).cdr.disp]
  648. @@go:
  649.     or    bl, bl        ; nil pointer?
  650.     je    @@fail
  651.     cmp    [ptype+bx], LISTTYPE
  652.     jne    @@fail
  653.     ldpage    es, bx
  654.     cmp    dx, [(LISTDEF es:si).car.disp] ; does displacement field of car match obj?
  655.     jne    @@more
  656.     cmp    cl, [(LISTDEF es:si).car.page] ; does page field of car match obj?
  657.     je    @@found
  658.     jmp    @@more
  659. @@found:            ; "eq" match found-- return pointer to current list cell
  660.     mov    [(REG di).bpage], bl
  661.     mov    [(REG di).disp], si
  662.     jmp    next_pc
  663. @@fail:                    ; no match-- return 'nil
  664.     xor    ax, ax
  665.     mov    [(REG di).bpage], al
  666.     mov    [(REG di).disp], ax
  667.     jmp    next_pc
  668. @@break:
  669.     jmp    in_shiftbreak
  670. ENDP    member
  671.  
  672. ;************************************************************************
  673. ;*                            al    ah    *
  674. ;* (assq obj list)                ASSQ    obj,    list    *
  675. ;*                                    *
  676. ;* Purpose: Scheme interpreter support for the assq primitive        *
  677. ;************************************************************************
  678. PROC    assq
  679.     get2op
  680.     save    <si>
  681. in_assq:
  682.     mov    bl, ah            ; copy the list register number
  683.     mov    si, [regs+bx.page]
  684.     cmp    [ptype+si], LISTTYPE
  685.     jne    @@fail
  686.     ldpage    es, si
  687.     mov    di, si
  688.     mov    si, [regs+bx.disp]    ; list operand in es:si
  689.     mov    bl, al            ; search object in dx:ax
  690.     mov    dx, [regs+bx.page]
  691.     mov    ax, [regs+bx.disp]
  692.     push    bx
  693.     mov    bx, di            ; Reload page number
  694.     call    lookup            ; search list for eq? comparison of obj
  695.     pop    si
  696.     mov    [regs+si.bpage], bl    ; store result
  697.     mov    [regs+si.disp], di
  698.     jmp    next_pc
  699. @@fail:                    ; error - return nil
  700.     mov    bl, al            ; copy register number
  701.     xor    ax, ax
  702.     mov    [regs+bx.bpage], al
  703.     mov    [regs+bx.disp], ax
  704.     jmp    next_pc
  705. ENDP    assq
  706.  
  707. ;************************************************************************
  708. ;*                             al    ah    *
  709. ;* (assv key alist)                ASSV    key,    alist    *
  710. ;*                                    *
  711. ;* Purpose: Scheme interpreter support for the assv primitive        *
  712. ;************************************************************************
  713. PROC    assv
  714.     get2op
  715.     save    <si>
  716.     mov    bl, al        ; key register
  717.     mov    di, [regs+bx.page]
  718.     test    [attrib+di], FIXNUMS or FLONUMS or BIGNUMS or STRINGS
  719.     jnz    @@notassq
  720.     jmp    in_assq
  721. @@notassq:
  722.     test    [attrib+di], FIXNUMS or FLONUMS or BIGNUMS
  723.     jnz    @@notassoc
  724.     jmp    in_assoc
  725. @@notassoc:                ; key is a number
  726.     lea    di, [regs+bx]        ; di=address of VM reg containing key
  727.     mov    bl, ah
  728.     lea    si, [regs+bx]        ; si=address of VM reg containing list
  729.     push    [(REG si).page]    ; tempsave "alist" VM reg
  730.     push    [(REG si).disp]
  731.     jmp    @@next
  732.  
  733. @@break:
  734.     jmp    in_shiftbreak
  735. @@more:
  736.     cmp    [s_break], 0        ; shift-break pressed?
  737.     jne    @@break
  738.     mov    bx, [(REG si).page]
  739.     ldpage    es, bx            ; get toplevel cons back into es:bx
  740.     mov    bx, [(REG si).disp]
  741.     xor    dx, dx
  742.     mov    dl, [(LISTDEF es:bx).cdr.page]        ; cdr down the alist
  743.     mov    ax, [(LISTDEF es:bx).cdr.disp]
  744.     mov    [(REG si).page], dx
  745.     mov    [(REG si).disp], ax
  746. @@next:                    ; loop over each element in the list
  747.     mov    bx, [(REG si).page]
  748.     cmp    bx, NIL_PAGE        ; at end of list?
  749.     jne    @@stillok
  750.     jmp    @@fail
  751. @@stillok:
  752.     cmp    [ptype+bx], LISTTYPE    ; looking at a cons?
  753.     jne    @@fail
  754.     ldpage    es, bx            ; get toplevel cons into es:bx
  755.     mov    bx, [(REG si).disp]
  756.     push    bx
  757.     mov    bl, [(LISTDEF es:bx).car.page]
  758.     mov    bh, 0
  759.     cmp    [ptype+bx], LISTTYPE    ; is car of toplevel cons also a cons?
  760.     je    @@chain
  761. @@popit:
  762.     pop    bx            ; normalize stack
  763. @@more1:
  764.     jmp    @@more            ; look at next toplevel cons
  765. @@chain:
  766.     mov    dx, bx
  767.     pop    bx            ; (es:bx=address of toplevel cons again)
  768.     mov    bx, [(LISTDEF es:bx).car.disp]    ; dx:bx=object ptr to 2nd level cons
  769.     ldpage    es, dx            ; es:bx=address of 2nd level cons cell
  770.     push    bx
  771.     mov    bl, [(LISTDEF es:bx).car.page]
  772.     mov    bh, 0
  773.     test    [attrib+bx], FIXNUMS or FLONUMS or BIGNUMS ; is its car numeric?
  774.     jz    @@popit
  775.     mov    [tmp_reg.page], bx    ; yes, move car ptr into tmp_reg
  776.     pop    bx            ; (es:bx=address of 2nd level cons again)
  777.     mov    bx, [(LISTDEF es:bx).car.disp]
  778.     mov    [tmp_reg.disp], bx
  779.     lea    bx, [tmp_reg]
  780.  
  781.     cmp    [(REG di).bpage], SPECFIX*2
  782.     jne    @@float
  783.     cmp    [(REG bx).bpage], SPECFIX*2
  784.     jne    @@float
  785.                     ; both key and list element are fixnums
  786.     mov    ax, [(REG bx).disp]    ; ax = list element,
  787.     cmp    ax, [(REG di).disp]    ; [di] = key
  788.     jne    @@more1
  789.     jmp    @@found
  790. @@fail:                    ; return nil
  791.     xor    ax, ax
  792.     mov    [(REG di).page], ax
  793.     mov    [(REG di).disp], ax
  794. @@done:
  795.     pop    [(REG si).disp]    ; restore original contents "alist" VM reg
  796.     pop    [(REG si).page]
  797.     jmp    next_pc
  798. @@found:                ; copy list object-pointer to key
  799.     mov    bx, [(REG si).page]
  800.     ldpage    es, bx
  801.     mov    bx, [(REG si).disp] ; es:bx=address of toplevel cons
  802.     xor    dx, dx
  803.     mov    dl, [(LISTDEF es:bx).car.page]
  804.     mov    ax, [(LISTDEF es:bx).car.disp]    ; move car of this cons to dest. register
  805.     mov    [(REG di).page], dx
  806.     mov    [(REG di).disp], ax
  807.     jmp    @@done
  808. @@float:
  809.     mov    ax, EQ_OP
  810.     call    arith2 C, ax, di, bx
  811.     or    ax, ax
  812.     jge    @@faillo2
  813.     jmp    sch_err
  814. @@faillo2:
  815.     jg    @@found        ; ax positive means "true"
  816.     jmp    @@more
  817. ENDP    assv
  818.  
  819. ;************************************************************************
  820. ;*                            al    ah    *
  821. ;* (assoc obj list)                ASSOC    obj,    list    *
  822. ;*                                    *
  823. ;* Purpose: Scheme interpreter support for the assoc primitive        *
  824. ;*                                    *
  825. ;* Register Usage:    dx - address of destination register        *
  826. ;*             es:si - pointer to current list cell        *
  827. ;************************************************************************
  828. PROC    assoc
  829.     get2op
  830.     save    <si>
  831.     mov    bl, al        ; copy search object's register number
  832.     mov    si, [regs+bx.page]
  833.     test    [attrib+si], FIXNUMS or SYMBOLS or CONTINU or CLOSURE or PORTS or CODE or CHARS
  834.     jz    @@notassq
  835.     jmp    in_assq
  836. in_assoc:
  837. @@notassq:
  838.     lea    dx, [regs+bx]        ; copy obj's reg address in dx
  839.     mov    bl, ah            ; copy list register number
  840.     mov    si, [regs+bx.disp]
  841.     mov    bl, [regs+bx.bpage]
  842. @@more:
  843.     or    bl, bl            ; end of list ?
  844.     jnz    @@stillok
  845. @@tofail:
  846.     jmp    @@fail
  847. @@stillok:
  848.     cmp    [ptype+bx], LISTTYPE
  849.     jne    @@tofail
  850.     ldpage    es, bx
  851.     mov    ax, bx
  852.     mov    bl, [(LISTDEF es:si).car.page]
  853.     cmp    [ptype+bx], LISTTYPE    ; does car point to list cell?
  854.     jne    @@notlist
  855.     mov    di, [(LISTDEF es:si).car.disp]
  856.     push    ax
  857.     ldpage    es, bx
  858.     xor    cx, cx
  859.     mov    cl, [(LISTDEF es:di).car.page]    ; copy car field into tmp_reg
  860.     mov    ax, [(LISTDEF es:di).car.disp]
  861.     mov    [tmp_reg.page], cx
  862.     mov    [tmp_reg.disp], ax
  863.     lea    ax, [tmp_reg]
  864.     push    dx
  865.     call    sequal_p C, ax, dx
  866.     pop    dx
  867.     pop    bx            ; restore page num
  868.     ldpage    es, bx
  869.     or    ax, ax            ; were pointers equal?
  870.     jne    @@found
  871. @@notlist:
  872.     xor    bx, bx
  873.     mov    bl, [(LISTDEF es:si).cdr.page]    ; follow cdr field
  874.     mov    si, [(LISTDEF es:si).cdr.disp]
  875.     cmp    [s_break], 0        ; has the shift-break key been depressed?
  876.     jne    @@shiftbreak
  877.     jmp    @@more
  878. @@shiftbreak:
  879.     jmp    in_shiftbreak
  880. @@found:                ; pointers "equal"-- return pointer to car field of current list cell
  881.     mov    di, dx            ; copy destination register address to di
  882.     mov    dl, [(LISTDEF es:si).car.page]    ; return cdr field of list cell
  883.     mov    ax, [(LISTDEF es:si).car.disp]
  884.     mov    [(REG di).bpage], dl
  885.     mov    [(REG di).disp], ax
  886.     jmp    next_pc
  887. @@fail:                ; return nil
  888.     mov    di, dx
  889.     xor    ax, ax
  890.     mov    [(REG di).page], ax
  891.     mov    [(REG di).disp], ax
  892.     jmp    next_pc
  893. ENDP    assoc
  894.     END
  895.